Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/vbdb/gfilebox.frm

Text File | 1995-09-06 | 9KB | 392 lines

VERSION 2.00
Begin Form GetFileBox
   BorderStyle     =   3  'Fixed Double
   ClientHeight    =   2640
   ClientLeft      =   1725
   ClientTop       =   2445
   ClientWidth     =   5055
   Height          =   3045
   Left            =   1665
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2640
   ScaleWidth      =   5055
   Top             =   2100
   Width           =   5175
   Begin ListBox Dirs
      Height          =   1200
      Left            =   1848
      Sorted          =   -1  'True
      TabIndex        =   4
      Top             =   1260
      Width           =   1530
   End
   Begin ListBox Files
      Height          =   1590
      Left            =   168
      Sorted          =   -1  'True
      TabIndex        =   3
      Top             =   912
      Width           =   1530
   End
   Begin CommandButton Command2
      Caption         =   "Cancel"
      Height          =   348
      Left            =   3948
      TabIndex        =   6
      Top             =   600
      Width           =   936
   End
   Begin CommandButton Command1
      Caption         =   "OK"
      Height          =   348
      Left            =   3948
      TabIndex        =   5
      Top             =   120
      Width           =   936
   End
   Begin TextBox FileSpec
      Height          =   288
      Left            =   1176
      TabIndex        =   2
      Top             =   132
      Width           =   2616
   End
   Begin Label Label2
      Caption         =   "&Directories:"
      Height          =   180
      Left            =   1848
      TabIndex        =   1
      Top             =   1008
      Width           =   1020
   End
   Begin Label Path
      Height          =   180
      Left            =   1848
      TabIndex        =   8
      Top             =   672
      Width           =   1992
   End
   Begin Label Label1
      Caption         =   "&Files:"
      Height          =   180
      Left            =   168
      TabIndex        =   0
      Top             =   672
      Width           =   600
   End
   Begin Label Label3
      Caption         =   "File &Name"
      Height          =   180
      Left            =   168
      TabIndex        =   7
      Top             =   168
      Width           =   936
   End
End
'
'Code for Visual Basic 1.0 and Windows 3.0
'(C)1991 Marquis Computing. All Rights Reserved.
'
'File Dialog box manager. Uses Windows system calls to increase
'speed and give a dialog box that dosen't have "visual basic"
'stamped all over it!
'

DefInt A-Z

Declare Function DlgDirList Lib "User" (ByVal hDlg As Integer, ByVal lpPathSpec As String, ByVal nIDListBox As Integer, ByVal nIDStaticPath As Integer, ByVal wFiletype As Integer) As Integer

Const TRUE = -1
Const FALSE = 0

'--- these constants are used by GetFileBox form
Const File_Box = &H7
Const Dir_Box = &H9
Const DrivesAndDir = &H10 Or &H4000 Or &H8000
Const FilesOnly = &H1

Dim File_Mask As String

Sub ChangeTo (FileSpec$)

    On Error GoTo ErrorHandler

    OldPath$ = CurDir$("")

    If InStr(FileSpec$, "[-") Then      'drive
        Drive$ = Mid$(FileSpec$, 3, Len(FileSpec$) - 3)
        ChDrive Drive$
        UpDateForm

    ElseIf InStr(FileSpec$, "[") Then   'dir
        SDir$ = Mid$(FileSpec$, 2, Len(FileSpec$) - 2)
        ChDir SDir$
        UpDateForm

    Else
    End If

    Exit Sub


ErrorHandler:
    ChDrive OldPath$
    ChDir OldPath$
    Exit Sub

End Sub

Sub Command1_Click ()


    GetFileBox.Hide
    GetFileBox.Path = CurDir$

End Sub

Sub Command2_Click ()

    GetFileBox.FileSpec.Text = ""
    GetFileBox.Hide

End Sub

Sub Dirs_DblClick ()


    '
    '
    '

    FileSpec.Text = File_Mask
    NewFileSpec$ = Dirs.Text
    ChangeTo NewFileSpec$

End Sub

Sub Dirs_KeyDown (KeyCode As Integer, Shift As Integer)

    FileSpec.Text = ProcessDir()

End Sub

Sub Dirs_KeyPress (KeyAscii As Integer)

    If KeyAscii = 13 Then
        FileSpec.Text = File_Mask
        NewFileSpec$ = Dirs.Text
        ChangeTo NewFileSpec$
    End If

End Sub

Sub Dirs_KeyUp (KeyCode As Integer, Shift As Integer)
FileSpec.Text = ProcessDir()
End Sub

Sub Dirs_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single)
FileSpec.Text = ProcessDir()
End Sub

Sub Files_DblClick ()

    '
    '
    '

    GetFileBox.Hide

End Sub

Sub Files_KeyDown (KeyCode As Integer, Shift As Integer)

    FileSpec.Text = Files.Text

End Sub

Sub Files_KeyPress (KeyAscii As Integer)

        If KeyAscii = 13 Then GetFileBox.Hide

End Sub

Sub Files_KeyUp (KeyCode As Integer, Shift As Integer)
    FileSpec.Text = Files.Text
End Sub

Sub Files_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single)

    FileSpec.Text = Files.Text

End Sub

Sub FileSpec_KeyPress (KeyAscii As Integer)

    If KeyAscii = 13 Then
        FileSpec.Text = UCase$(FileSpec.Text)
        KeyAscii = 0
        UpDateForm
    End If

End Sub

Sub Form_Load ()

    '
    'Center form
    '

    '--- Center form
    Screen.MousePointer = 11
    WinWidth = (Screen.Width - GetFileBox.Width) \ 2
    WinHieght = (Screen.Height - GetFileBox.Height) \ 2
    GetFileBox.Move WinWidth, WinHieght

    '--- load the files box
    If FileSpec.Text = "" Then FileSpec.Text = "*.*"

    '--- display current path
    ThisDir$ = LCase$(CurDir$)
    If Len(ThisDir$) > 20 Then
      ThisDir1$ = Left$(ThisDir$, 3)
      ThisDir2$ = "..."
      ThisDir3$ = Right$(ThisDir$, 15)
      ThisDir$ = ThisDir1$ + ThisDir2$ + ThisDir3$
    End If
    GetFileBox.Path.Caption = ThisDir$

    Screen.MousePointer = 0

End Sub

Sub Form_Resize ()

    File_Mask = FileSpec.Text

    '--- load the files box
    LoadDir File_Box, File_Mask, FilesOnly

    '--- load the dir/drive box
    LoadDir Dir_Box, File_Mask, DrivesAndDir


End Sub

Function GetMask$ (FileSpec$)

    '
    '
    '

    For X = Len(FileSpec$) To 1 Step -1
      If Mid$(FileSpec$, X, 1) = "." Then
        GetMask$ = "*" + Mid$(FileSpec$, X)
        Exit For
      End If
    Next

End Function

Sub LoadDir (ListBox, Mask$, Item)

    '
    'Loads a listbox with a variety of disk file items. Usually the array
    'of items are file(s), dir(s) or drive(s). Uses a windows system call
    'for enhanced speed and versatility.
    '
    'On entry
    '---------------------------------------------------------------------
    'ListBox:   the number of the list box (i.e., 1,2 etc.)
    '
    'Mask$  :   a file specification mask (i.e., *.DBF, ?.DAT, *.SY?)
    '
    'Item   :   an integer which represents the type of item to load into
    '           the list box where:
    '
    '           &H0     = read/write files only
    '           &H1     = read-only files
    '           &H2     = hidden files
    '           &H4     = system files
    '           &H10    = sub dirs
    '           &H20    = archive
    '           &H4000  = drives
    '           &H8000  = force ONLY those items meeting Mask$ and Item%
    '                     criteria to be loaded.
    '
    'NOTE:  Items may be OR'd to combine -- for example to load system files
    '       and drives ONLY, you would set up Item% as follows:
    '
    '               Item% = &H4 Or &H4000 Or &H8000
    'on exit
    '--------------------------------------------
    'The list box is filled with contents specified (if any found)
    '
    '

     '--- get windows handle of form
     hDlg = GetFileBox.hWnd

     '--- ASCIIZ file spec
     lpPathSpec$ = LTrim$(RTrim$(Mask$)) + Chr$(0)

     '--- assign list box number
     nIDListBox = ListBox

     '--- no static path id
     nIDStaticPath = 0

     '--- assign item
     wFiletype = Item

     '--- cal